home *** CD-ROM | disk | FTP | other *** search
VERSION 4.00 Begin VB.Form frmGame ClientHeight = 4164 ClientLeft = -72 ClientTop = 1752 ClientWidth = 7488 ControlBox = 0 'False Height = 4548 Left = -120 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 4164 ScaleWidth = 7488 Top = 1416 Visible = 0 'False Width = 7584 WindowState = 2 'Maximized Begin VB.CommandButton pbDrop Caption = "Drop" Height = 300 Left = 6048 TabIndex = 30 Top = 3456 Width = 972 End Begin VB.CommandButton pbWayOut Caption = "WayOut" Height = 300 Left = 4704 TabIndex = 29 Top = 3648 Width = 972 End Begin VB.CommandButton pbCarry Caption = "Carry" Height = 300 Left = 3456 TabIndex = 28 Top = 3456 Width = 972 End Begin VB.CommandButton pbBackward Caption = "Backward" Height = 204 Left = 5760 TabIndex = 27 Top = 2976 Width = 972 End Begin VB.CommandButton pbDown Caption = "Down" Height = 204 Left = 3648 TabIndex = 26 Top = 2976 Width = 972 End Begin VB.CommandButton pbSouth Caption = "Sourth" Height = 204 Left = 4704 TabIndex = 25 Top = 2784 Width = 972 End Begin VB.CommandButton pbEast Caption = "East" Height = 204 Left = 5760 TabIndex = 24 Top = 2592 Width = 972 End Begin VB.CommandButton pbWest Caption = "West" Height = 204 Left = 3648 TabIndex = 23 Top = 2592 Width = 972 End Begin VB.CommandButton pbUp Caption = "Up" Height = 204 Left = 5760 TabIndex = 22 Top = 2208 Width = 972 End Begin VB.CommandButton pbNorth Caption = "North" Height = 204 Left = 4704 TabIndex = 21 Top = 2400 Width = 972 End Begin VB.CommandButton pbForward Caption = "Forward" Height = 204 Left = 3648 TabIndex = 20 Top = 2208 Width = 972 End Begin VB.TextBox txtMaxScore Enabled = 0 'False Height = 288 Left = 6240 TabIndex = 17 Text = "100" Top = 1632 Width = 588 End Begin VB.TextBox txtNumTreasures Enabled = 0 'False Height = 288 Left = 6240 TabIndex = 16 Text = "15" Top = 1248 Width = 588 End Begin VB.TextBox txtNumRooms Enabled = 0 'False Height = 288 Left = 6240 TabIndex = 15 Text = "100" Top = 864 Width = 588 End Begin VB.TextBox txtScore Enabled = 0 'False Height = 288 Left = 5184 TabIndex = 13 Text = "0" Top = 1632 Width = 588 End Begin VB.TextBox txtTreasuresRecovered Enabled = 0 'False Height = 288 Left = 5184 TabIndex = 12 Text = "0" Top = 1248 Width = 588 End Begin VB.TextBox txtRoomsVisited Enabled = 0 'False Height = 288 Left = 5184 TabIndex = 11 Text = "1" Top = 864 Width = 588 End Begin VB.TextBox txtMoves Enabled = 0 'False Height = 288 Left = 5184 TabIndex = 10 Text = "0" Top = 480 Width = 588 End Begin VB.CommandButton pbAbout Caption = "About" Height = 252 Left = 6144 TabIndex = 5 Top = 288 Width = 972 End Begin VB.ListBox lstInventory Height = 1200 Left = 120 TabIndex = 3 Top = 2760 Width = 2652 End Begin VB.TextBox txtLocation Height = 1452 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 0 Top = 840 Width = 2652 End Begin VB.Label Label10 Caption = "of" Height = 204 Left = 5952 TabIndex = 19 Top = 1728 Width = 204 End Begin VB.Label Label9 Caption = "of" Height = 204 Left = 5952 TabIndex = 18 Top = 1344 Width = 204 End Begin VB.Label Label8 Caption = "of" Height = 204 Left = 5952 TabIndex = 14 Top = 960 Width = 204 End Begin VB.Label Label7 Alignment = 1 'Right Justify Caption = "Score" Height = 180 Left = 4416 TabIndex = 9 Top = 1728 Width = 612 End Begin VB.Label Label6 Alignment = 1 'Right Justify Caption = "Treasures recovered" Height = 180 Left = 3360 TabIndex = 8 Top = 1344 Width = 1668 End Begin VB.Label Label5 Alignment = 1 'Right Justify Caption = "Rooms visited" Height = 180 Left = 3840 TabIndex = 7 Top = 960 Width = 1188 End Begin VB.Label Label4 Alignment = 1 'Right Justify Caption = "Moves" Height = 180 Left = 4416 TabIndex = 6 Top = 600 Width = 636 End Begin VB.Label Label3 Caption = "Inventory" Height = 252 Left = 120 TabIndex = 4 Top = 2400 Width = 2052 End Begin VB.Label Label2 Caption = "Location" Height = 252 Left = 120 TabIndex = 2 Top = 480 Width = 732 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Visit all of the rooms and return all of the treasures to the entrance." Height = 252 Left = 120 TabIndex = 1 Top = 120 Width = 4812 End Attribute VB_Name = "frmGame" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Public bEuclidean As Boolean Public nDimensions As Long Public nGame As Long Private bConnected() As Boolean Private bDirectionFound As Boolean Private bDirectionUsed(255, 4, 2) As Boolean Private bInitialized As Boolean Private bPathFound As Boolean Private bRoomUsed() As Boolean Private bTreasureCarried As Boolean Private bVisited() As Boolean Private bWeaponRoomFound As Boolean Private bWidthsFound As Boolean Private dblScore As Double Private nCell(15, 15, 15, 15) As Long Private nCoordinate(4) As Long Private nCoordinateNext(4) As Long Private nDimension1 As Long Private nDimension2 As Long Private nDirection1 As Long Private nDirection2 As Long Private nDirectionsPossible As Long Private nDirectionsUsed(255) As Long Private nGuardRoom() As Long Private nMaxWidth As Long Private nMoves As Long Private nRoom1 As Long Private nRoom2 As Long Private nRooms As Long Private nScore As Long Private nTCoordinate As Long Private nTreasure1 As Long Private nTreasure2 As Long Private nTreasureRoom() As Long Private nTreasures As Long Private nTreasuresCarried As Long Private nTreasuresRecovered As Long Private nTrial As Long Private nVisited As Long Private nVolume As Long Private nWayOutDimension(255) As Long Private nWayOutDirection(255) As Long Private nWayOutHead As Long Private nWayOutPtr As Long Private nWeaponRoom() As Long Private nWidth(4) As Long Private nXCoordinate As Long Private nYCoordinate As Long Private nZCoordinate As Long Private strDescription() As String Private strGuard() As String Private strLine As String Private strTreasure() As String Private strTreasures As String Private strWayOut As String Private strWeapon() As String Private Declare Function GetModuleFileName Lib "KERNEL32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal strFileName As String, ByVal nFileNameLength As Long) As Long Private Function GetProgramPath() As String Dim nCharIndex As Long Dim nFileNameLength As Long Dim nLastSlash As Long Dim nModuleHandle As Long Dim strFileName As String Dim strResult As String strResult = "C:\VB\TREASURE\" 'For development nModuleHandle = 0 nFileNameLength = 256 strFileName = String(nFileNameLength, 0) nFileNameLength = GetModuleFileName(nModuleHandle, strFileName, nFileNameLength) If nFileNameLength > 0 Then nLastSlash = 0 For nCharIndex = 1 To nFileNameLength If Mid(strFileName, nCharIndex, 1) = "\" Then nLastSlash = nCharIndex End If Next nCharIndex If nLastSlash > 0 Then If Mid(strFileName, nLastSlash + 1, nFileNameLength - nLastSlash) <> "VB32.EXE" Then strResult = Left(strFileName, nLastSlash) End If End If End If GetProgramPath = strResult End Function Private Sub GameUpdate() Dim Response As Long txtMoves.Text = nMoves If (Not bEuclidean) Then If nXCoordinate < 0 Then nYCoordinate = nWidth(1) - 1 - nYCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nXCoordinate = nWidth(0) - 1 Else If nXCoordinate >= nWidth(0) Then nYCoordinate = nWidth(1) - 1 - nYCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nXCoordinate = 0 End If End If If nYCoordinate < 0 Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nYCoordinate = nWidth(1) - 1 Else If nYCoordinate >= nWidth(1) Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nYCoordinate = 0 End If End If If nZCoordinate < 0 Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nYCoordinate = nWidth(1) - 1 - nYCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nZCoordinate = nWidth(2) - 1 Else If nZCoordinate >= nWidth(2) Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nYCoordinate = nWidth(1) - 1 - nYCoordinate nTCoordinate = nWidth(3) - 1 - nTCoordinate nZCoordinate = 0 End If End If If nTCoordinate < 0 Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nYCoordinate = nWidth(1) - 1 - nYCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = nWidth(3) - 1 Else If nTCoordinate >= nWidth(3) Then nXCoordinate = nWidth(0) - 1 - nXCoordinate nYCoordinate = nWidth(1) - 1 - nYCoordinate nZCoordinate = nWidth(2) - 1 - nZCoordinate nTCoordinate = 0 End If End If End If nRoom1 = nCell(nXCoordinate, nYCoordinate, nZCoordinate, nTCoordinate) If ((nRoom1 <> 0) And (strWayOut = "") And (Int(100# * Rnd) = 0)) Then nRoom2 = 0 Do While nRoom2 <= 0 nXCoordinate = Int(CDbl(nWidth(0)) * Rnd) nYCoordinate = Int(CDbl(nWidth(1)) * Rnd) nZCoordinate = Int(CDbl(nWidth(2)) * Rnd) nTCoordinate = Int(CDbl(nWidth(3)) * Rnd) nRoom2 = nCell(nXCoordinate, nYCoordinate, nZCoordinate, nTCoordinate) Loop If nRoom2 <> nRoom1 Then nRoom1 = nRoom2 Response = MsgBox("A flock of bats grabs you, flies you through the caverns, and drops you.", vbOKOnly, "Yeowwww!") End If End If strWayOut = "" nTreasuresRecovered = 0 nTreasure1 = 0 bTreasureCarried = False Do While (nTreasure1 < nTreasures) And (Not bTreasureCarried) If nTreasureRoom(nTreasure1) < 0 Then bTreasureCarried = True Else nTreasure1 = nTreasure1 + 1 End If Loop If bTreasureCarried Then If Int(CDbl(2 * nRooms) * Rnd) = 0 Then nRoom2 = 0 Do While nRoom2 <= 0 nDimension1 = 0 Do While nDimension1 < nDimensions nCoordinate(nDimension1) = Int(CDbl(nWidth(nDimension1)) * Rnd) nDimension1 = nDimension1 + 1 Loop nRoom2 = nCell(nCoordinate(0), nCoordinate(1), nCoordinate(2), nCoordinate(3)) If nRoom1 = nRoom2 Then nRoom2 = -1 End If Loop nTreasure1 = 0 Do While nTreasure1 < nTreasures If nTreasureRoom(nTreasure1) < 0 Then nTreasureRoom(nTreasure1) = nRoom2 End If nTreasure1 = nTreasure1 + 1 Loop bTreasureCarried = False Response = MsgBox("As he leaves, he says, 'Arggh! I'll hide me booty better this time.'", vbOKOnly, "A pirate jumps out of the shadows and takes your treasure.") End If End If nTreasure1 = 0 nTreasure2 = 0 strTreasures = "" lstInventory.Clear nTreasuresCarried = 0 Do While nTreasure1 < nTreasures If nTreasureRoom(nTreasure1) = 0 Then nTreasuresRecovered = nTreasuresRecovered + 1 If nRoom1 = 0 Then strTreasures = strTreasures & " There's " & strTreasure(nTreasure1) & " here. " End If Else If nTreasureRoom(nTreasure1) = nRoom1 Then strTreasures = strTreasures & " There's " & strTreasure(nTreasure1) & " here. " If nGuardRoom(nTreasure1) = nRoom1 Then strLine = Left(strGuard(nTreasure1), 1) If ((strLine = "a") Or (strLine = "e") Or (strLine = "i") Or (strLine = "o") Or (strLine = "u")) Then strTreasures = strTreasures & " It's guarded by an " & strGuard(nTreasure1) & "." Else strTreasures = strTreasures & " It's guarded by a " & strGuard(nTreasure1) & "." End If End If Else If nTreasureRoom(nTreasure1) = -1 Then bTreasureCarried = True nTreasuresCarried = nTreasuresCarried + 1 nTreasure2 = nTreasure2 + 1 lstInventory.AddItem strTreasure(nTreasure1) End If End If End If If nWeaponRoom(nTreasure1) = nRoom1 Then strLine = Left(strWeapon(nTreasure1), 1) If ((strLine = "a") Or (strLine = "e") Or (strLine = "i") Or (strLine = "o") Or (strLine = "u")) Then strTreasures = strTreasures & " There's an " & strWeapon(nTreasure1) & " here." Else strTreasures = strTreasures & " There's a " & strWeapon(nTreasure1) & " here." End If Else If nWeaponRoom(nTreasure1) = -1 Then nTreasure2 = nTreasure2 + 1 lstInventory.AddItem strWeapon(nTreasure1) End If End If nTreasure1 = nTreasure1 + 1 Loop txtTreasuresRecovered.Text = nTreasuresRecovered txtNumTreasures.Text = nTreasures If (Not bVisited(nRoom1)) Then nVisited = nVisited + 1 bVisited(nRoom1) = True End If txtRoomsVisited.Text = nVisited txtNumRooms.Text = nRooms dblScore = 25# * CDbl(nVisited) / CDbl(nRooms) + 75# * CDbl(nTreasuresRecovered) / CDbl(nTreasures) + 45# * CDbl(nTreasuresCarried) / CDbl(nTreasures) If nVisited > 5 * nRooms Then dblScore = dblScore - CDbl(nVisited) / (5# * CDbl(nRooms)) If dblScore < 0# Then dblScore = 0# End If End If nScore = Int(dblScore) txtScore.Text = nScore txtMaxScore.Text = 100 txtLocation.Text = strDescription(nRoom1) & strTreasures If strTreasures = "" Then pbCarry.Enabled = False Else pbCarry.Enabled = True End If If ((nRoom1 = 0) And (bTreasureCarried)) Then pbDrop.Enabled = True Else pbDrop.Enabled = False End If If bConnected(nRoom1, 0, 0) Then pbNorth.Enabled = True Else pbNorth.Enabled = False End If If bConnected(nRoom1, 0, 1) Then pbSouth.Enabled = True Else pbSouth.Enabled = False End If If bConnected(nRoom1, 1, 0) Then pbEast.Enabled = True Else pbEast.Enabled = False End If If bConnected(nRoom1, 1, 1) Then pbWest.Enabled = True Else pbWest.Enabled = False End If If bConnected(nRoom1, 2, 0) Then pbUp.Enabled = True Else pbUp.Enabled = False End If If bConnected(nRoom1, 2, 1) Then pbDown.Enabled = True Else pbDown.Enabled = False End If If bConnected(nRoom1, 3, 0) Then pbForward.Enabled = True Else pbForward.Enabled = False End If If bConnected(nRoom1, 3, 1) Then pbBackward.Enabled = True Else pbBackward.Enabled = False End If End Sub Private Sub Form_Load() Dim strLine As String Dim strProgramPath As String MousePointer = 11 strWayOut = "" Randomize nGame strProgramPath = GetProgramPath() Open strProgramPath & "treasure.dat" For Input As 1 Input #1, nTreasures ReDim strTreasure(nTreasures) ReDim strGuard(nTreasures) ReDim nGuardRoom(nTreasures) ReDim nTreasureRoom(nTreasures) ReDim nWeaponRoom(nTreasures) ReDim strWeapon(nTreasures) nTreasure1 = 0 Do While nTreasure1 < nTreasures Line Input #1, strTreasure(nTreasure1) Line Input #1, strGuard(nTreasure1) Line Input #1, strWeapon(nTreasure1) nTreasure1 = nTreasure1 + 1 Loop Close 1 Open strProgramPath & "descript.dat" For Input As 1 Input #1, nRooms ReDim strDescription(nRooms) ReDim bVisited(nRooms) ReDim bConnected(nRooms, 4, 2) ReDim bRoomUsed(nRooms) nRoom1 = 0 Do While nRoom1 < nRooms Line Input #1, strLine strDescription(nRoom1) = "You're in " & strLine bVisited(nRoom1) = False nDimension1 = 0 Do While nDimension1 < nDimensions nDirection1 = 0 Do While nDirection1 < 2 bConnected(nRoom1, nDimension1, nDirection1) = False nDirection1 = nDirection1 + 1 Loop nDimension1 = nDimension1 + 1 Loop nRoom1 = nRoom1 + 1 Loop Close 1 nMaxWidth = 1 + Int(CDbl(2 * nRooms) ^ (1# / CDbl(nDimensions))) bWidthsFound = False Do While Not bWidthsFound nDimension1 = 0 nVolume = 1 Do While nDimension1 < nDimensions nWidth(nDimension1) = nMaxWidth - Int(2# * Rnd) nVolume = nVolume * nWidth(nDimension1) nDimension1 = nDimension1 + 1 Loop If nVolume > nRooms Then bWidthsFound = True End If Loop nDimension1 = nDimensions Do While nDimension1 < 4 nWidth(nDimension1) = 1 nDimension1 = nDimension1 + 1 Loop nRoom1 = 1 Do While nRoom1 < nRooms nRoom2 = 1 + Int(CDbl(nRooms - 1) * Rnd) strLine = strDescription(nRoom1) strDescription(nRoom1) = strDescription(nRoom2) strDescription(nRoom2) = strLine nRoom1 = nRoom1 + 1 Loop nXCoordinate = 0 Do While nXCoordinate < nWidth(0) nYCoordinate = 0 Do While nYCoordinate < nWidth(1) nZCoordinate = 0 Do While nZCoordinate < nWidth(2) nTCoordinate = 0 Do While nTCoordinate < nWidth(3) nCell(nXCoordinate, nYCoordinate, nZCoordinate, nTCoordinate) = -1 nTCoordinate = nTCoordinate + 1 Loop nZCoordinate = nZCoordinate + 1 Loop nYCoordinate = nYCoordinate + 1 Loop nXCoordinate = nXCoordinate + 1 Loop nXCoordinate = 0 nYCoordinate = 0 nZCoordinate = 0 nTCoordinate = 0 nCoordinate(0) = nXCoordinate nCoordinate(1) = nYCoordinate nCoordinate(2) = nZCoordinate nCoordinate(3) = nTCoordinate nRoom1 = 0 nRoom2 = 0 nCell(0, 0, 0, 0) = 0 Do While nRoom1 < (nRooms - 1) bDirectionFound = False Do While Not bDirectionFound nDirection1 = Int(2# * Rnd) nDimension1 = Int(CDbl(nDimensions) * Rnd) If bEuclidean Then If nCoordinate(nDimension1) + 2 * nDirection1 - 1 >= 0 Then If nCoordinate(nDimension1) + 2 * nDirection1 - 1 < nWidth(nDimension1) Then bDirectionFound = True End If End If Else bDirectionFound = True End If Loop bConnected(nRoom2, nDimension1, nDirection1) = True nCoordinateNext(0) = nCoordinate(0) nCoordinateNext(1) = nCoordinate(1) nCoordinateNext(2) = nCoordinate(2) nCoordinateNext(3) = nCoordinate(3) nCoordinateNext(nDimension1) = nCoordinate(nDimension1) + 2 * nDirection1 - 1 If (Not bEuclidean) Then If nCoordinateNext(nDimension1) < 0 Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1 Else If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = 0 End If End If End If If nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) < 0 Then nRoom1 = nRoom1 + 1 nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) = nRoom1 End If nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) bConnected(nRoom2, nDimension1, 1 - nDirection1) = True nCoordinate(0) = nCoordinateNext(0) nCoordinate(1) = nCoordinateNext(1) nCoordinate(2) = nCoordinateNext(2) nCoordinate(3) = nCoordinateNext(3) Loop nTreasure1 = 0 Do While nTreasure1 < nTreasures nTreasureRoom(nTreasure1) = 1 + Int(CDbl(nRooms - 1) * Rnd) nGuardRoom(nTreasure1) = nTreasureRoom(nTreasure1) bWeaponRoomFound = False Do While Not bWeaponRoomFound nWeaponRoom(nTreasure1) = 1 + Int(CDbl(nRooms - 1) * Rnd) If nWeaponRoom(nTreasure1) <> nTreasureRoom(nTreasure1) Then bWeaponRoomFound = True End If Loop nTreasure1 = nTreasure1 + 1 Loop bInitialized = True GameUpdate MousePointer = 0 End Sub Private Sub Form_Unload(Cancel As Integer) Dim Response As Long If bInitialized Then If nScore < 20 Then Response = MsgBox("Your score ranks you as a beginner.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.") Else If nScore < 40 Then Response = MsgBox("Your score ranks you as a novice adventurer.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.") Else If nScore < 60 Then Response = MsgBox("Your score ranks you as a seasoned explorer.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.") Else If nScore < 80 Then Response = MsgBox("Your score ranks you as a grissly old prospector.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.") Else Response = MsgBox("Your score ranks you as an expert treasure hunter; there is no higher rating.", vbOKOnly, "You scored " & CStr(nScore) & " out of 100 points.") End If End If End If End If End If End Sub Private Sub pbAbout_Click() Dim Response As Long Response = MsgBox("Adventures in 4 Dimensions" + Chr(13) + Chr(13) + "Copyright " + Chr(169) + " 1997 James L. Dean (csvcjld@nomvs.lsumc.edu)" + Chr(13) + Chr(13) + "This application may be distributed or used without payment to James L. Dean." + Chr(13) + Chr(13) + "As per Microsoft's license for Visual Basic 4.0, the end-user may not distribute the components having names starting with other than " _ + Chr(34) + "treasure" + Chr(34) + "," + Chr(34) + "init" + Chr(34) + "," + Chr(34) + "game" + Chr(34) + "," + Chr(34) + "descript" + Chr(34) + ", or " + Chr(34) + "file_id" + Chr(34) + ".", vbOKOnly, "About Adventures in 4 Dimensions Release 4.4") End Sub Private Sub pbBackward_Click() nMoves = nMoves + 1 nTCoordinate = nTCoordinate + 1 GameUpdate End Sub Private Sub pbCarry_Click() Dim Response As Long nTreasure1 = 0 Do While nTreasure1 < nTreasures If nWeaponRoom(nTreasure1) = nRoom1 Then nWeaponRoom(nTreasure1) = -1 End If nTreasure1 = nTreasure1 + 1 Loop nTreasure1 = 0 Do While nTreasure1 < nTreasures If nTreasureRoom(nTreasure1) = nRoom1 Then If nWeaponRoom(nTreasure1) < 0 Then nTreasureRoom(nTreasure1) = -1 nTreasuresRecovered = nTreasuresRecovered + 1 If nGuardRoom(nTreasure1) = nRoom1 Then nGuardRoom(nTreasure1) = -1 nWeaponRoom(nTreasure1) = -2 Response = MsgBox("You're " & strWeapon(nTreasure1) & " overcomes the " & strGuard(nTreasure1) & ".", vbOKOnly, "Way to go!") End If Else Response = MsgBox("You carry nothing to overcome the " & strGuard(nTreasure1) & ".", vbOKOnly, "Whoops!") End If End If If nWeaponRoom(nTreasure1) = nRoom1 Then nWeaponRoom(nTreasure1) = -1 End If nTreasure1 = nTreasure1 + 1 Loop GameUpdate End Sub Private Sub pbDown_Click() nMoves = nMoves + 1 nZCoordinate = nZCoordinate + 1 GameUpdate End Sub Private Sub pbDrop_Click() nTreasure1 = 0 Do While nTreasure1 < nTreasures If nTreasureRoom(nTreasure1) = -1 Then nTreasureRoom(nTreasure1) = 0 End If nTreasure1 = nTreasure1 + 1 Loop GameUpdate End Sub Private Sub pbEast_Click() nMoves = nMoves + 1 nYCoordinate = nYCoordinate - 1 GameUpdate End Sub Private Sub pbForward_Click() nMoves = nMoves + 1 nTCoordinate = nTCoordinate - 1 GameUpdate End Sub Private Sub pbNorth_Click() nMoves = nMoves + 1 nXCoordinate = nXCoordinate - 1 GameUpdate End Sub Private Sub pbSouth_Click() nMoves = nMoves + 1 nXCoordinate = nXCoordinate + 1 GameUpdate End Sub Private Sub pbUp_Click() nMoves = nMoves + 1 nZCoordinate = nZCoordinate - 1 GameUpdate End Sub Private Sub pbWayOut_Click() Dim Response As Long bPathFound = False If ((bTreasureCarried) And (nRoom1 <> 0)) Then nCoordinate(0) = nXCoordinate nCoordinate(1) = nYCoordinate nCoordinate(2) = nZCoordinate nCoordinate(3) = nTCoordinate nWayOutHead = 0 nRoom2 = 0 Do While nRoom2 < nRooms bRoomUsed(nRoom2) = False nRoom2 = nRoom2 + 1 Loop bRoomUsed(nRoom1) = True nDirectionsUsed(nWayOutHead) = 0 nDirectionsPossible = 2 * nDimensions nDimension1 = 0 Do While nDimension1 < nDimensions nDirection1 = 0 Do While nDirection1 < 2 bDirectionUsed(nWayOutHead, nDimension1, nDirection1) = False nDirection1 = nDirection1 + 1 Loop nDimension1 = nDimension1 + 1 Loop strWayOut = "" nRoom2 = nRoom1 nTrial = 0 MousePointer = 11 Do While (nTrial < 500) And (nRoom2 <> 0) And (nWayOutHead < 255) nTrial = nTrial + 1 bDirectionFound = False Do While (Not bDirectionFound) And (nDirectionsUsed(nWayOutHead) < nDirectionsPossible) nDirection1 = Int(2# * Rnd) nDimension1 = Int(CDbl(nDimensions) * Rnd) If (Not bDirectionUsed(nWayOutHead, nDimension1, nDirection1)) Then bDirectionUsed(nWayOutHead, nDimension1, nDirection1) = True nDirectionsUsed(nWayOutHead) = nDirectionsUsed(nWayOutHead) + 1 If bConnected(nRoom2, nDimension1, nDirection1) Then nCoordinateNext(0) = nCoordinate(0) nCoordinateNext(1) = nCoordinate(1) nCoordinateNext(2) = nCoordinate(2) nCoordinateNext(3) = nCoordinate(3) nCoordinateNext(nDimension1) = nCoordinate(nDimension1) + 2 * nDirection1 - 1 If (Not bEuclidean) Then If nCoordinateNext(nDimension1) < 0 Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1 Else If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = 0 End If End If End If If (Not bRoomUsed(nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)))) Then bDirectionFound = True End If End If End If Loop If bDirectionFound Then nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) nWayOutHead = nWayOutHead + 1 bRoomUsed(nRoom2) = True nDirectionsUsed(nWayOutHead) = 0 nDimension2 = 0 Do While nDimension2 < nDimensions nDirection2 = 0 Do While nDirection2 < 2 bDirectionUsed(nWayOutHead, nDimension2, nDirection2) = False nDirection2 = nDirection2 + 1 Loop nDimension2 = nDimension2 + 1 Loop nWayOutDimension(nWayOutHead) = nDimension1 nWayOutDirection(nWayOutHead) = 1 - nDirection1 Select Case nDimension1 Case 0 If nDirection1 = 0 Then strWayOut = strWayOut & "N" Else strWayOut = strWayOut & "S" End If Case 1 If nDirection1 = 0 Then strWayOut = strWayOut & "E" Else strWayOut = strWayOut & "W" End If Case 2 If nDirection1 = 0 Then strWayOut = strWayOut & "U" Else strWayOut = strWayOut & "D" End If Case Else If nDirection1 = 0 Then strWayOut = strWayOut & "F" Else strWayOut = strWayOut & "B" End If End Select Else nDirection1 = nWayOutDirection(nWayOutHead) nDimension1 = nWayOutDimension(nWayOutHead) nCoordinateNext(0) = nCoordinate(0) nCoordinateNext(1) = nCoordinate(1) nCoordinateNext(2) = nCoordinate(2) nCoordinateNext(3) = nCoordinate(3) nCoordinateNext(nDimension1) = nCoordinateNext(nDimension1) + 2 * nDirection1 - 1 If (Not bEuclidean) Then If nCoordinateNext(nDimension1) < 0 Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = nWidth(nDimension1) - 1 Else If nCoordinateNext(nDimension1) >= nWidth(nDimension1) Then nDimension2 = 0 Do While nDimension2 < nDimensions nCoordinateNext(nDimension2) = nWidth(nDimension2) - nCoordinateNext(nDimension2) - 1 nDimension2 = nDimension2 + 1 Loop nCoordinateNext(nDimension1) = 0 End If End If End If nRoom2 = nCell(nCoordinateNext(0), nCoordinateNext(1), nCoordinateNext(2), nCoordinateNext(3)) nWayOutHead = nWayOutHead - 1 If Len(strWayOut) > 1 Then strWayOut = Left(strWayOut, Len(strWayOut) - 1) Else strWayOut = "" End If End If nCoordinate(0) = nCoordinateNext(0) nCoordinate(1) = nCoordinateNext(1) nCoordinate(2) = nCoordinateNext(2) nCoordinate(3) = nCoordinateNext(3) Loop MousePointer = 0 If nRoom2 = 0 Then bPathFound = True End If End If If bPathFound Then nTreasure1 = 0 nRoom2 = 0 Do While (nTreasure1 < nTreasures) And (nRoom2 >= 0) nRoom2 = nTreasureRoom(nTreasure1) If nRoom2 >= 0 Then nTreasure1 = nTreasure1 + 1 End If Loop nRoom2 = nRoom1 Do While nRoom1 = nRoom2 nRoom2 = 1 + Int(CDbl(nRooms - 1) * Rnd) Loop nTreasureRoom(nTreasure1) = nRoom2 Response = MsgBox("As he leaves, he shouts the letters, '" & strWayOut & "'.", vbOKOnly, "The pirate takes one of your treasures.") GameUpdate Else Response = MsgBox("Try again later.", vbOKOnly, "Nothing happens.") End If End Sub Private Sub pbWest_Click() nMoves = nMoves + 1 nYCoordinate = nYCoordinate + 1 GameUpdate End Sub 
(.txt)